(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

open XNum
open UTypes
open Dim
open Substitute
open GlyphMetric
open FontMetric
open Box
  
let rec discard_glue items =
  let rec iter cmds items =
    match items with
      | [] -> (List.rev cmds, [])
      | i :: is ->
          match i with
            | `Glyph _ -> (List.rev cmds, items)
            | `Kern _ -> iter cmds is
            | `Break ((_, _, _, _, [|  |])) -> iter cmds is (* only break boxes where no-break is empty *)
            | `Break _ -> (List.rev cmds, items)
            | `Command b | `Box b ->
                match b.b_contents with
                  | GlueBox (_, disc) ->
                      if disc then
                        iter cmds is
                      else
                        (List.rev cmds, items)
                  | BreakBox (_, _, _, _, []) -> iter cmds is (* only break boxes where no-break is empty *)
                  | EmptyBox -> iter cmds is
                  | _ ->
                      if is_real_box b then
                        (List.rev cmds, items)
                      else
                        iter (i :: cmds) is
  in
    iter [] items
  
let rec discard_glue_array from_pos to_pos items =
  let rec iter cmds pos =
    if pos > to_pos then
      (List.rev cmds, pos)
    else
      match items.(pos) with
        | `Glyph _ -> (List.rev cmds, pos)
        | `Kern _ -> iter cmds (pos + 1)
        | `Break ((_, _, _, _, [|  |])) -> iter cmds (pos + 1) (* only break boxes where no-break is empty *)
        | `Break _ -> (List.rev cmds, pos)
        | `Command b | `Box b ->
            match b.b_contents with
              | GlueBox (_, disc) ->
                  if disc then
                    iter cmds (pos + 1)
                  else
                    (List.rev cmds, pos)
              | BreakBox (_, _, _, _, []) -> iter cmds (pos + 1) (* only break boxes where no-break is empty *)
              | EmptyBox -> iter cmds (pos + 1)
              | _ ->
                  if is_real_box b then
                    (List.rev cmds, pos)
                  else
                    iter (items.(pos) :: cmds) (pos + 1)
  in
    iter [] from_pos
  
let rec box_add_lig_kern boxes =
  let insert_lig lig_char keep_first keep_second b1 b2 bs =
    match (b1.b_contents, b2.b_contents) with
      | (CharBox (_, font, text1), CharBox (_, _, text2)) ->
          let lig_text = combine_glyph_texts text1 text2 in
            (if keep_first then [ b1 ] else []) @
              [ new_glyph_box (Simple lig_char) font lig_text] @ 
              (if keep_second then [ b2 ] else []) @ bs
      | _ -> assert false
  in
  let collect_commands boxes =
    let cmds = ListBuilder.make () in
    let rec iter boxes =
      match boxes with
        | [] -> ((ListBuilder.get cmds), [])
        | b :: bs ->
            if is_real_box b then
              ((ListBuilder.get cmds), boxes)
            else
              (ListBuilder.add cmds b;
               iter bs)
    in
      iter boxes
  in
  let process_lig_kern b1 boxes =
    match collect_commands boxes with
      | (cmds, []) -> b1 :: cmds
      | (cmds, ((b2 :: rest as bs))) ->
          begin
            match ((b1.b_contents), (b2.b_contents)) with
              | (CharBox (c1, f1, _t1), CharBox (c2, f2, _t2)) ->
                  if f1 == f2 then
                    begin
                      match get_lig_kern f1 c1 c2 with
                        | NoLigKern -> b1 :: (cmds @ (box_add_lig_kern bs))
                        | Kern k ->
                            b1 :: (new_kern_box k num_zero) ::
                              (cmds @ (box_add_lig_kern boxes))
                        | Ligature (c, s, k1, k2) ->
                            let new_boxes = insert_lig c k1 k2 b1 b2 rest in
                              (XList.take s new_boxes) @
                                (box_add_lig_kern (XList.drop s new_boxes))
                    end
                  else b1 :: (cmds @ (box_add_lig_kern bs))
              | _ -> b1 :: (cmds @ (box_add_lig_kern bs))
          end
  in
    match boxes with
      | [] -> []
      | b :: bs ->
          if is_char_box b then
            process_lig_kern b bs
          else
            b :: (box_add_lig_kern bs)
  
type ('result, 'cmd) composer = {
  result : 'result ListBuilder.builder;
  current : ((box, 'cmd) char_item) ListBuilder.builder;
  end_word : ('result, 'cmd) composer -> unit;
  process_box : ('result, 'cmd) composer -> box -> 'result;
  mutable font : font_metric;
  mutable composer : (font_metric, box, 'cmd) Substitute.glyph_composer;
  mutable hyphen_params : JustHyph.hyphen_params;
}

let set_font composer font glyph_composer =
  if composer.composer != glyph_composer || composer.font != font then
    begin
      composer.end_word composer;
      composer.font <- font;
      composer.composer <- glyph_composer;
    end
  
let set_hyphen_params composer hyphen_params =
  composer.hyphen_params <- hyphen_params
  
let add_char composer chr =
  ListBuilder.add composer.current (`Char chr)
  
let add_break composer p h pre post no =
  ListBuilder.add composer.current (`Break ((p, h, pre, post, no)))
  
let ignore_break _ _ _ _ _ _ = ()
  
let add_kern composer x y = ListBuilder.add composer.current (`Kern ((x, y)))
let add_cmd  composer cmd = ListBuilder.add composer.current (`Command cmd)
  
let add_box composer box =
  composer.end_word composer;
  ListBuilder.add composer.result (composer.process_box composer box)
  
let get_contents composer () =
  composer.end_word composer;
  ListBuilder.get composer.result
  
let process_box_to_box  _ box = box  
let process_box_to_item _ box = `Box box
  
let end_word_just_hyph composer =
  match ListBuilder.get composer.current with
    | [] -> ()
    | word ->
        let items =
          JustHyph.convert_to_glyphs_and_add_breaks composer.hyphen_params composer.font composer.composer word
        in
          ListBuilder.add_list composer.result (List.map simple_item_to_box (JustHyph.add_lig_kern ~keep_breaks:true items))
  
let end_word_ligature composer =
  match ListBuilder.get composer.current with
    | [] -> ()
    | word ->
        ListBuilder.add_list composer.result
          (List.map
             simple_item_to_box
             (JustHyph.add_lig_kern ~keep_breaks:false
                (Array.to_list (JustHyph.convert_to_glyphs composer.font composer.composer word))))
  
let end_word_hyph_only composer =
  match ListBuilder.get composer.current with
    | [] -> ()
    | word ->
        let items = JustHyph.convert_to_glyphs_and_add_breaks composer.hyphen_params composer.font composer.composer word in
          ListBuilder.add_list composer.result items
  
let end_word_char_item composer =
  ListBuilder.add_list composer.result (ListBuilder.get composer.current)

let end_word_glyph_item composer =
  match ListBuilder.get composer.current with
    | [] -> ()
    | word ->
        ListBuilder.add_list composer.result
          begin
            composer.composer
              begin
                Array.fold_right (fun i is -> (JustHyph.strip_composer i) :: is)
                  (JustHyph.convert_to_glyphs composer.font composer.composer word)
                  []
              end
          end
  
let make_composer add_break composer =
  ( { Builder.add_char = add_char composer;
      Builder.add_break = add_break composer;
      Builder.add_kern = add_kern composer;
      Builder.add_box = add_box composer;
      Builder.add_cmd = add_cmd composer;
      Builder.set_font = set_font composer;
      Builder.set_hyphen_params = set_hyphen_params composer },
    get_contents composer )
  
let just_hyph_builder font composer params =
  make_composer add_break
    { result = ListBuilder.make ();
      current = ListBuilder.make ();
      end_word = end_word_just_hyph;
      process_box = process_box_to_box;
      font = font;
      composer = composer;
      hyphen_params = params }
  
let ligature_builder font composer params =
  make_composer add_break
    {  result = ListBuilder.make ();
       current = ListBuilder.make ();
       end_word = end_word_ligature;
       process_box = process_box_to_box;
       font = font;
       composer = composer;
       hyphen_params = params }
  
let hyph_only_builder font composer params =
  make_composer add_break
    { result = ListBuilder.make ();
      current = ListBuilder.make ();
      end_word = end_word_hyph_only;
      process_box = process_box_to_item;
      font = font;
      composer = composer;
      hyphen_params = params }
  
let char_item_builder font composer params =
  make_composer add_break
    { result = ListBuilder.make ();
      current = ListBuilder.make ();
      end_word = end_word_char_item;
      process_box = process_box_to_item;
      font = font;
      composer = composer;
      hyphen_params = params }
  
let glyph_item_builder font composer params =
  make_composer add_break
    { result = ListBuilder.make ();
      current = ListBuilder.make ();
      end_word = end_word_glyph_item;
      process_box = process_box_to_item;
      font = font;
      composer = composer;
      hyphen_params = params }
